{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}


--------------------------------------------------------------------------------
-- |
-- Module      :  ZCSV.FieldParser
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser monad.
--
--------------------------------------------------------------------------------

module ZCSV.FieldParser where


import ZCSV.Utils

import Control.Applicative
import Control.Monad

import Data.Char



--------------------------------------------------------------------------------
-- Field parser


type Fk ans   = String -> Maybe ans
type Sk ans a = a -> Fk ans -> String -> Maybe ans


newtype FieldParser a = FieldParser {
    getFieldParser :: forall ans. Sk ans a -> Fk ans -> String -> Maybe ans }



ret :: a -> FieldParser a
ret x = FieldParser $ \sc -> sc x

-- the bind (>>=) of Monad
bind :: FieldParser a -> (a -> FieldParser b) -> FieldParser b 
bind m f = FieldParser $ \sk -> getFieldParser m $ \a -> getFieldParser (f a) sk


app :: FieldParser (a -> b) -> FieldParser a -> FieldParser b
app mf ma = FieldParser $ \sk -> getFieldParser mf $ \f -> getFieldParser ma $ \a -> sk (f a)


-- mplus of MonadPlus
alt :: FieldParser a -> FieldParser a -> FieldParser a
alt p q = FieldParser $ \sk fk -> getFieldParser p sk (getFieldParser q sk fk)

-- the mzero of MonadPlus, empty of Alternative
failure :: FieldParser a
failure = FieldParser $ \_ fk inp -> fk inp



instance Functor FieldParser where
  fmap f ma = FieldParser $ \sk -> getFieldParser ma (sk . f) 

instance Applicative FieldParser where
  pure  = ret
  (<*>) = app

instance Monad FieldParser where
  return = ret
  (>>=)  = bind


instance MonadPlus FieldParser where
  mzero = failure
  mplus = alt

instance Alternative FieldParser where
  empty = failure
  (<|>) = alt


runFieldParser :: FieldParser a -> String -> Maybe a
runFieldParser p inp = getFieldParser p sc fc inp
  where
    sc = \ans _ _ -> Just ans
    fc = \_ -> Nothing

--------------------------------------------------------------------------------
-- Low level combinators

-- | Need to check this vis backtracking...
whatever :: FieldParser String
whatever = FieldParser $ \sk fk inp -> sk inp fk ""

trimRight :: FieldParser String
trimRight = FieldParser $ \sk fk inp -> sk (trimR inp) fk ""

trimLeft :: FieldParser String
trimLeft = FieldParser $ \sk fk inp -> sk (trimL inp) fk ""

trimLeftRight :: FieldParser String
trimLeftRight = FieldParser $ \sk fk inp -> sk (trimLR inp) fk ""



lookahead :: FieldParser a -> (a -> FieldParser b) -> FieldParser b 
lookahead p f  = FieldParser $ \sk fk -> 
    getFieldParser p (\x fc -> getFieldParser (f x) sk fc) fk


-- | @satisfies@ needs /bind/ so its monadic and not applicative.
satisfies :: FieldParser a -> (a -> Bool) -> FieldParser a
satisfies p f = p >>= (\x -> if f x then return x else mzero)


satisfy :: (Char -> Bool) -> FieldParser Char
satisfy test = FieldParser $ \sk fk inp -> case inp of
    (a:rest) | test a -> sk a fk rest
    _                 -> fk inp


-- | End-of-field.
--
eof :: FieldParser ()
eof = FieldParser $ \sk fk inp -> case inp of
    [] -> sk () fk inp
    _  -> fk inp



--------------------------------------------------------------------------------
-- General combinators


-- | Applicative cons.
--
-- Utility - not exported.
--
(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) p1 p2 = (:) <$> p1 <*> p2

-- | Applicative T - reverse fmap. 
--
-- Utility - not exported.
--
(<#>) :: Functor f => f a -> (a -> b) -> f b
(<#>) = flip fmap



choice :: [FieldParser a] -> FieldParser a
choice = foldr (<|>) empty 

   
count :: Int -> FieldParser a -> FieldParser [a]
count i p | i <= 0    = pure []
          | otherwise = p <:> count (i-1) p 
          
between :: FieldParser open -> FieldParser close -> FieldParser a -> FieldParser a
between o c a = o *> a <* c

          
option :: a -> FieldParser a -> FieldParser a
option x p          = p <|> pure x

optionMaybe :: FieldParser a -> FieldParser (Maybe a)
optionMaybe = optional


-- aka Parsec\'s /optional/
optionUnit :: FieldParser a -> FieldParser ()
optionUnit p = () <$ p <|> pure ()


skipMany :: FieldParser a -> FieldParser ()
skipMany p = many_p
  where many_p = some_p <|> pure ()
        some_p = p       *> many_p

skipMany1 :: FieldParser a -> FieldParser ()
skipMany1 p = p *> skipMany p

-- | 'many1' an alias for Control.Applicative 'some'. 
many1 :: FieldParser a -> FieldParser [a]
many1 = some

sepBy :: FieldParser a -> FieldParser b -> FieldParser [a]
sepBy p sep = sepBy1 p sep <|> pure []

sepBy1 :: FieldParser a -> FieldParser b -> FieldParser [a]
sepBy1 p sep = p <:> step where
    step = (sep *> p) <:> step <|> pure []

sepEndBy :: FieldParser a -> FieldParser b -> FieldParser [a]
sepEndBy p sep = sepEndBy1 p sep <|> pure []

sepEndBy1 :: FieldParser a -> FieldParser b -> FieldParser [a]
sepEndBy1 p sep = (p <* sep) <:> step where
    step = (p <* sep) <:> step <|> pure []
    
manyTill :: FieldParser a -> FieldParser b -> FieldParser [a]
manyTill p end = step <|> pure [] where
    step = p <:> ((end <#> pure[]) <|> step)

manyTill1 :: FieldParser a -> FieldParser b -> FieldParser [a]
manyTill1 p end = p <:> step where
    step = (end <#> pure []) <|> (p <:> step)
    

-- The chain parsers need @bind@ so they have to be monadic 
-- rather than applicative
--


chainl1 :: FieldParser a -> FieldParser (a -> a -> a) -> FieldParser a
chainl1 p op = p >>= rest 
  where rest x = mplus (op >>= \f -> p >>= \a -> rest (f x a)) (return x) 
               
chainr1 :: FieldParser a -> FieldParser (a -> a -> a) -> FieldParser a
chainr1 p op = scan 
   where 
     scan   = p >>= rest 
     rest x = mplus (op >>= \f -> scan >>= \a -> rest (f x a)) (return x) 

chainl :: FieldParser a -> FieldParser (a -> a -> a) -> a -> FieldParser a
chainl p op v = mplus (chainl1 p op) (return v)

chainr :: FieldParser a -> FieldParser (a -> a -> a) -> a -> FieldParser a
chainr p op v = mplus (chainr1 p op) (return v)

--------------------------------------------------------------------------------
-- Char parsers

oneOf :: [Char] -> FieldParser Char
oneOf cs = satisfy (`elem` cs)

noneOf :: [Char] -> FieldParser Char
noneOf cs = satisfy (\c -> not $ c `elem` cs)

char :: Char -> FieldParser Char
char c = satisfy (== c)

string :: String -> FieldParser String
string = work
  where
    work []     = return []
    work (c:cs) = char c <:> work cs

anyChar         :: FieldParser Char 
anyChar         = satisfy (const True)

upper           :: FieldParser Char
upper           = satisfy isUpper

lower           :: FieldParser Char
lower           = satisfy isLower

alpha           :: FieldParser Char
alpha           = satisfy isAlpha

alphaNum        :: FieldParser Char
alphaNum        = satisfy isAlphaNum

digit           :: FieldParser Char
digit           = satisfy isDigit

digiti          :: FieldParser Int
digiti          = digitToInt <$> digit

hexDigit        :: FieldParser Char
hexDigit        = satisfy isHexDigit

octDigit        :: FieldParser Char
octDigit        = satisfy isOctDigit


-- newline
-- tab

space           :: FieldParser Char
space           = satisfy isSpace

spaces          :: FieldParser ()
spaces          = () <$ many space 


--------------------------------------------------------------------------------
-- Tokens

-- Util

swrap :: Char -> String
swrap c = [c]

lexeme          :: FieldParser a -> FieldParser a
lexeme p        = p <* spaces

{-

-- | Generally wrap with this rather than @lexeme@...
--
field           :: FieldParser a -> FieldParser a
field p         = p <* terminus
  where
    terminus = eof <|> (() <$ char ',')
-}

semi            :: FieldParser String
semi            = lexeme (swrap <$> char ';')

-- comma

colon           :: FieldParser String
colon           = lexeme (swrap <$> char ':')

dot             :: FieldParser String
dot             = lexeme (swrap <$> char '.')

semiSep         :: FieldParser a -> FieldParser [a]
semiSep p       = sepBy p semi

semiSep1        :: FieldParser a -> FieldParser [a]
semiSep1 p      = sepBy1 p semi


quotedString    :: FieldParser String
quotedString    = outer
  where
    outer       = char '"' <:> inner
    inner       = do { x <- anyChar
                     ; rest <- if x /= '"' then inner else terminus
                     ; return (x:rest)
                     } 
                                 
    terminus    = char '"' <:> inner
               <|> pure ""

anything       :: FieldParser String
anything       = many (noneOf ['\n', '"', ','])


decimal         ::FieldParser Int
decimal         = outer 
  where
    outer       = digiti >>= inner
    inner ac    = do { i <- digiti; inner (ac * 10 + i) } <|> return ac 

